perm filename T1X.FOR[P11,LCS] blob
sn#409420 filedate 1979-01-30 generic text, type T, neo UTF8
00100 C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
00200 SUBROUTINE TRANS(JJJ)
00250 DIMENSION II(216)
00300 CIN DIMENSION IINS(108)
00400 C W(35) FOR PARAMETERS
00500 CIN COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,4),K
00600 COMMON /TR/I(80),RX(100),JX(100),LX(12),K
00700 1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
00800 1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
00900 1,ENDX,J /KNAM/IPLAY,JFLNM,JPLAY /IFIRST/IFIRST,IDT
01000 1 /INST/INST(27)
01100 1 /WDZ/WDZ(14),JWD(12)
01200 COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
01300 COMMON LL /P/W(1) /CONV/ICONV /FQDR/FQDR(28,27),INSN
01400 INTEGER FQDR
01500 C****************CHECK NEAR HERE FOR NEEDED CHANGES **************
01600 CXX DOUBLE PRECISION IDBL,JANP,JBLA,JFLNM,JDBG,
01700 CXX 1 INST,INAM,JSEMI,ICOLON
01800 EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
01900 1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
02000 1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
02100 1,(IAROW,LX(7)),(W1,W),(W3,W(3)),(W2,W(2))
02200 CXX DATA LX/' ',';', '*','/','-','+'
02300 CXX 1,'←','=', '<', ',', '(', ')'/, IFIRST/-1/,IOPEN/-1/
02400 C****************CHECK NEAR HERE FOR NEEDED CHANGES **************.
02410 C THE BIG NUMBER BELOW IS A LEFT ARROW.
02420
02500 DATA LX/' ',';', '*','/','-','+'
02600 1,"575004020100,'=','<' ,',' ,'(', ')'/,
02700 1 IDOT/'.'/, IDEV/1/,JPRNT/1/,JWRT/-1/,JFLNM/'TRNS'/
02800 1,JBLA/' '/,JDBG/'# '/,JPERC/'% '/,JSEMI/'; '/
02900 C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
03000 DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./,JQUOT/'" '/
03100 1,JEXP/'! '/,JANP/'& '/,ICONV/-1/,JCOLON/': '/
03500 C ICONV=-1 MEANS WRITE A SOUND FILE. (=0 = WRITE A FILE FOR 'SMPLS' PROG.)
03600
03700 GO TO (555,500) JJJ
03710 CXX GO TO (555,5002) JJJ
03800 555 LLLL=0
03900 401 IF(IFIRST)404, 5,600
04000 404 IGEN=-1
04100 JPLAY=0
04200 IF(INUM.NE.0)GO TO 30
04300 DO 411 K=1,27
04400 411 INST(K)=0
04500 CIN DO 411 K=1,108
04600 CIN411 IINS(K)=0
04700 C ZERO OUT INSTR. NAME ARRAY.
04800 30 IPLAY=0
04900 ENDX=0
05000 JSEM=0
05100 INS=-1
05200 402 IDEV=1
05300 412 TYPE 1
05400 1 FORMAT(' INPUT? '$)
05500 100 FORMAT(' >'$)
05600 2 FORMAT(A4)
05700 ACCEPT 2,IDBL
05800 C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
05900 IF(IDBL.NE.JBLA)GO TO 400
06000 IDEV=5
06100 GO TO 5
06200 400 IF(IDBL.NE.JANP)GO TO 602
06210 JPRNT=-JPRNT
06220 GO TO 412
06300 C!*** & IS PRNT-NOPRNT FLIPFLOP
06361 602 IF(IDBL.NE.JQUOT)GO TO 408
06381 C!*** " FOR INSTRUMENT LIST.
06401 DO 606 K=1,INUM
06421 CC JK=NPAR(K)-2
06441 JK=INSNUM(K)
06461 MM=NPAR(JK)-2
06481 606 TYPE 607,INST(K),JK,MM
06501 CIN606 TYPE 607,(INST(K,L),L=1,4),JK,NPAR(JK)
06521 CC606 TYPE 607,(INST(K,L),L=1,4),INSNUM(K),JK
06541 GO TO 402
06561 607 FORMAT(1X,A4,' NUM=',I2,' PARAMS=',I2)
06581 CIN607 FORMAT(1X,4A1,' NUM=',I2,' PARAMS=',I2)
06601 C!*** PRINTS INST INFO.
06621 408 IF(IDBL.NE.JEXP)GO TO 603
06641 C TRIGGERS ICONV FLIPFLOP
06661 IF(ICONV)GO TO 2408
06681 ICONV=-1
06701 TYPE 3408
06721 GO TO 412
06741 2408 ICONV=0
06761 TYPE 4408
06781 GO TO 412
06801 3408 FORMAT(' OUTPUT=TEST.SND'/)
06821 4408 FORMAT(' OUTPUT=TEST.DAT'/)
06900 603 IF(IDBL.EQ.JPERC)CALL PLAY
06910 C TYPE % TO RE-PLAY SOUND
07010 CXX IF(IDBL.NE.JDBG)GO TO 410
07020 CXX4448 TYPE 4023
07030 CXX4446 TYPE 4445
07040 CXX ACCEPT 51,KI
07050 CXX IF(KI.EQ.0)GO TO 4022
07060 CXX IF(KI.GT.0)GO TO 4447
07070 C******** THIS STUFF FOR DIAGNOSIS
07100 CXX IF(KI.EQ.-1)TYPE 2325,IGEN
07200 CXX IF(KI.EQ.-2)TYPE 2325,IPRNT
07300 CXX IF(KI.EQ.-3)TYPE 2325,IPLAY
07400 CXX IF(KI.EQ.-4)TYPE 2325,JSEM
07500 CXX IF(KI.EQ.-5)TYPE 2325,J
07600 CXX IF(KI.EQ.-6)TYPE 2325,MM
07700 CXX GO TO 4446
07800 CXX4022 IF(IDEV.EQ.1)GO TO 402
07900 C GO BACK TO 'INPUT' OR '>'
08000 CXX GO TO 502
08100 C THIS WILL TYPE OUT ELEMENTS OF LX ARRAY.
08200 CXX4447 TYPE 2326,LX(KI)
08300 CXX TYPE 2325,LX(KI)
08400 CXX GO TO 4446
08500 CXX4445 FORMAT(' TYPE LX NUMB. '$)
08600 CXX4023 FORMAT(' IGEN, IPRNT, IPLAY, JSEM, J, MM'/)
08700 CXX2324 FORMAT(1X12F/)
08800 CXX2325 FORMAT(1X5I/)
08900 2326 FORMAT(1X80A1)
09000 410 IF(IDBL.EQ.JCOLON)CALL EXIT
09100 C TYPE ':' TO EXIT AND CLOSE ALL FILES.
09200 CALL IFILE(1,IDBL)
09210 C NOW IT BELIEVES YOU'VE TYPED A FILE NAME.
09300 CX CALL OPEN(1,IDBL,0,'RDO')
09400 4 FORMAT(80A1)
09500 C****************
09600 CX TYPE 2325,JSEM
09700 CX TYPE 2325,J
09800 CX TYPE 2325,MM
09900 5 IF(JSEM.AND.J.LT.MM)GO TO 305
10000 IF(JSEM.NE.99)GO TO 502
10100 IFIRST=IFIRST+10
10200 GO TO 555
10300 600 JSEM=0
10400 IFIRST=IFIRST-10
10500 INS=-1
10600 502 IF(IDEV.NE.5)GO TO 601
10700 CX TYPE 2325,IDEV
10800 C*******************************
10900 IF(KSEM.EQ.0)GO TO 503
11000 C KSEM=-1=WE'λE JUST SEEN A SEMICOLON, =0=READ MORE STUFF ON NEXT LINE.
11100 IF(IGEN.NE.2)IGEN=-1
11200 503 TYPE 100
11300 C*******************************
11400 601 READ(IDEV,4,END=404)I
11700 IF(IDEV.EQ.5)GO TO 1232
11800 KI=80
11900 1233 IF(I(KI).NE.IBLA)GO TO 1234
12000 KI=KI-1
12100 IF(KI.GT.0)GO TO 1233
12200 1234 IF(JPRNT.LT.0)TYPE 2326,(I(IJI),IJI=1,KI)
12300 GO TO 1408
12400 1232 DO 1235 K=1,80
12500 1235 IF(I(K).NE.IBLA)GO TO 1408
12600 C!**** USE BLANK (<CR>) TO RETURN TO 'INPUT?' (UNLESS IN PLAY LOOP)
12700 IF(JPLAY.GE.0)GO TO 404
12800 GO TO 503
16100 1408 DO 407 K=1,100
16200 407 JX(K)=IBLA
16300 DO 405 K=1,80
16400 IF(I(K).EQ.LESS)GO TO 5
16500 405 IF(I(K).NE.IBLA)GO TO 406
16600 GO TO 5
16700 406 MM=0
16800 DO 4061 J=2,100,2
16900 4061 RX(J)=0
17000 J=-1
17100 IPRNT=0
17200 119 JI=0
17300 9 M=0
17400 N=JI+1
17500 6 JI=JI+1
17600 KCHAR=I(JI)
17700 DO 7 L=1,12
17800 7 IF(KCHAR.EQ.LX(L))GO TO 8
17900 M=M+1
18000 GO TO 6
18100 C!**** NO STRING CAN EXCEED 10 CHARS.
18200 8 IF(KCHAR.EQ.LESS)GO TO 15
18300 IF(M.EQ.0)GO TO 140
18400 KSEM=0
18500 C KSEM WILL = -1 WHEN WE HIT NEXT SEMICOLON.
18600 IF(M.GT.10)M=10
18700 MM=MM+1
18800 IF(MM.LE.50)GO TO 88
18900 TYPE 888,(I(JJ),JJ=N,N+9)
19000 STOP
19100 888 FORMAT(' LINE TOO LONG -- ',10A1)
19200 88 JJ=I(N)
19300 IF(JJ.GT.'9')GO TO 16
19400 IF(JJ.NE.IDOT.AND.JJ.LT.'0')GO TO 16
19500 CXX IF(JJ.GT.8249)GO TO 16
19600 CXX IF(JJ.NE.IDOT.AND.JJ.LT.8240)GO TO 16
19700 C**** 8240='0' 8249='9'
19800 C!***** JUMP IF 1ST CHAR. IS A LETTER.
19900 Y=0
20000 DOT=10.
20100 DO 18 JK=N,N+M-1
20200 JA=I(JK)
20300 IF(JA.NE.IDOT)GO TO 17
20400 DOT=.1
20500 GO TO 18
20600 CXX17 X=JA-8240
20700 17 X=NASCI(JA)
20800 C!**** CHANGE ASCII INTO NUMBER
20900 IF(DOT.LT.1)GO TO 19
21000 Y=Y*DOT+X
21100 GO TO 18
21200 19 Y=Y+X*DOT
21300 DOT=DOT/10.
21400 18 CONTINUE
21500 RX(MM*2-1)=Y
21600 RX(MM*2)=-9999.0
21700 GO TO 140
21800
21900 16 JK=MM*2-1
22000 CX JX(JK)=0
22100 CX RX(JK)=0
22200 CX JX(JK+1)=0
22300 CX RX(JK+1)=0
22400 CALL MPACK(M,I(N),JX(JK),N)
22500 C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
22600 IJ=JX(JK)
22700 IF(IJ.GE.0)GO TO 144
22800 C IF IJ < 0, THEN IT'S A LETTER
22900 JX(MM*2)=M
23000 C SAVE THE WD CNT OF POTENTIAL INST. NAME.
23100 GO TO 143
23200 144 IF(IJ.NE.408)GO TO 140
23300 TYPE 244,WDZ,JWD
23400 GO TO 503
23500 244 FORMAT(15(1XA4))
23600 140 IF(IJ.NE.413)GO TO 143
23700 INS=1
23800 C!*** 'UNIT GENERATOR' IS RESERVED FOR NEW ONES.
23900 GO TO 5
24000 143 IF(KCHAR.EQ.IBLA)GO TO 10
24100 IF(L.EQ.8)KCHAR=IAROW
24200 C!::: CHANGE = INTO ←
24300 IF(KCHAR.NE.ISEMI)GO TO 141
24400 C NEXT JUMPS IF DUPLICATE SEMICOLON FOUND.
24500 IF(KSEM.LT.0)GO TO 10
24600 C NOW WE'VE SEEN A SEMICOLON
24700 KSEM=-1
24800 141 MM=MM+1
24900 KI=MM*2-1
25000 JX(KI)=KCHAR
25100 10 IF(I(JI+1).NE.IBLA)GO TO 11
25200 JI=JI+1
25300 GO TO 10
25400 11 IF(JI.LT.80)GO TO 9
25500 C NOW WE HAVE ALL ITEMS IN IX ARRAY
25600 IF(MM.GT.1)GO TO 15
25700 C CATCH 'WORD ;' AT END OF LINE
25800 IF(KSEM.LT.0)GO TO 15
25900 IF(M.EQ.0)GO TO 5
26000 15 MM=MM*2
26100 IF(IJ.NE.404)GO TO 142
26200 CCC IF(IXJ.NE.KPRNT)GO TO 142
26300 INS=-1
26400 C!***** FOR 'PRINT'
26500 IPRNT=-1
26600 142 J=-1
26700 IF(INS.LT.0)GO TO 305
26800 IF(INS.EQ.2)GO TO 305
26900 MM=0
27000 INS=-1
27100 C!***** NOW INITIALIZATION COMPLETE
27200 GO TO 5
27300 50 IF(IGEN)308,309,309
27400 309 LL=LL-1
27500 IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
27600 C!*** FOUND 'END'
27700 GO TO 59
27800 308 W1=1
27900 IK=W2
28000 IF(LL.GT.NPAR(IK))GO TO 56
28100 54 IF(LL.LT.3)LL=3
28200 DO 55 K=LL,NPAR(IK)
28300 55 W(K)=P(K-2)
28400 C!***** GET INFO ALREADY IN PARAMS
28500 56 DO 57 K=3,LL
28600 57 P(K-2)=W(K)
28700 C!**** FILL UP P LIST AGAIN
28800 X=W3
28900 C!*** EXCHANGE W2 AND W3, ACTION TIME, INST #
29000 W3=W2
29100 W2=X
29200 58 LL=NPAR(IK)
29300 DO 52 K=5,LL
29400 KI=FQDR(K-4,IK)
29500 IF(KI)53,52,2352
29600 2352 W(K)=RMAG/W(K)
29700 GO TO 52
29800 53 W(K)=RMAG*W(K)
29900 52 CONTINUE
30000 IF(ENDX.LT.W2+P2)ENDX=W2+P2
30100 59 IF(W1.NE.2.)GO TO 592
30200 IF(LL.EQ.2)GO TO 597
30300 C JUMP IF 'END' OF INS DEF.
30400 IF(LL.NE.3)GO TO 595
30500 C JUMP IF NOT AN INST DEF.
30600 PSV=0
30700 SV=35
30800 C EXPLAIN USE OF STORAGE PARAMS!!
30900 INSN=W3
31000 C INS DEF NUM.
31100 CC JINS=INUM
31200 C LIST OF INST NAMES MUST FOLLOW 'INS 0 N;' !!!ALWAYS!!!
31300 CIN596 INUM=INUM+1
31400 CIN596 READ(IDEV,2)INST(INUM)
31500 596 READ(IDEV,2,END=587)INAM
31600 IF(INAM.EQ.JSEMI)GO TO 592
31700 C LIST OF INST NAMES TERMINATES WITH ';'.
31800 DO 588 K=1,INUM
31900 IF(INAM.NE.INST(K))GO TO 588
32000 INST(K)=INAM
32100 INSNUM(K)=INSN
32200 GO TO 589
32300 587 PAUSE 'MISSING SEMICOLON'
32400 588 CONTINUE
32500 INUM=INUM+1
32600 INST(INUM)=INAM
32700 CIN READ(IDEV,4)(INST(INUM,K),K=1,4)
32800 CIN IF(INST(INUM,1).EQ.ISEMI)GO TO 599
32900 C LIST OF INST NAMES TERMINATES WITH ';'.
33000 INSNUM(INUM)=INSN
33100 589 IF(JPRNT)TYPE 244,INAM
33200 CIN IF(JPRNT)TYPE 2326,(INST(INUM,K),K=1,4)
33300 GO TO 596
33400 CIN599 INUM=INUM-1
33500
33600 595 DO 593 K=3,LL
33700 X=W(K)
33800 IF(X.LT.0.OR.X.GT.100)GO TO 593
33900 IF(X.GT.PSV)PSV=X
34000 C CHECK FOR OVERLAPPING PARAM NUMS.
34100 593 CONTINUE
34200 IF(W3.NE.102.AND.W3.NE.105.AND.W3.NE.111.AND.W3.NE.104
34300 1 .AND.W3.NE.115)GO TO 592
34400 C 115=NOS, 102=OSC, 105=ENV, 104=RAI (3 STOR. LOCS), 111=RAH (2 STOR. LOCS)
34500 C NEXT SETS UP STORAGE LOCATIONS FOR OSC, ENV, RAN, AND RAH.
34600 X=W3
34700 594 LL=LL+1
34800 W(LL)=SV
34900 SV=SV-1
35000 C DECREMENT THE HIGH PARAM NUM.
35100 IF(SV.LT.PSV)PAUSE 'PARAMETER OVERLAP'
35200 CIN IF(SV.LT.PSV)CALL ERROR(5)
35300 C IF STORAGE PARAM NUM. OVERLAPS WITH INSTS/'S PARAMS = ERROR
35400 IF(X.NE.111.AND.X.NE.104)GO TO 592
35500 IF(X.EQ.111)X=0
35600 IF(X.EQ.104)X=111
35700 GO TO 594
35800
35900 597 NPAR(INSN)=PSV
36000 C SAVE THE HIGHEST PARAM NUM.
36100
36200 592 IF(JPRNT.GE.0)GO TO 591
36300 TYPE 51,LL,(W(K),K=1,LL)
36400 CXX WRITE(22,51)LL,(W(K),K=1,LL)
36500 C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
36600 591 IF(JWRT.GE.0)GO TO 500
36700 CZZ ???? IF(IOPEN.LT.0)CALL OFILE(21,JFLNM)
36900 C OPENS FILE, IF NOT ALREADY OPEN.
37000 CZZ WRITE(21)LL,(W(K),K=1,LL)
37100 IDT=2
37200 RETURN
37300
37500 500 IFIRST=0
37600 IF(IGEN.EQ.0)IGEN=-1
37700 IF(W1.NE.6)GO TO 555
37800 RETURN
37900 C W1=6 = 'FINISH;' [W ARRAY IS EQUIV. TO P ARRAY IN MUSIC5]
38000
38100 306 IF(JPRNT.LT.0)TYPE 1307,(W(K),K=1,LL-1)
38200 IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
38300 IPRNT=0
38400 C!** RESET NO-PRNT FLAG
38500 JSEM=0
38600 C!** RESET SEMICOLON FLAG
38700 INS=-1
38800 IF(J.GE.MM-1)GO TO 5
38900 C!** GO READ ANOTHER LINE
39000 305 CALL MSCAN
39100 IF(KSEM.LT.0)GO TO 303
39200 JSEM=1
39300 C FOR CONTINUATION LINES (NO SEMICOLON AT END OF LINE, GO TO NEXT)
39400 KSEM=0
39500 303 IF(IPRNT.LT.0)GO TO 306
39600 IF(J.LT.MM)JSEM=-1
39700 C!**** STILL MORE CHARS TO COME.
39800 IF(ENDX.GE.0)GO TO 302
39900 ENDX=0
40000 GO TO 500
40100 302 IF(JSEM)50,5,5
40200 51 FORMAT(I3,35F10.3/)
40300 307 FORMAT('+',F8.2,$)
40400 1307 FORMAT(F10.3)
40500 END
40600
40700 FUNCTION NASCI(N)
40800 DATA IEX/536870912/,IZERO/'0'/
40900 C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
41000 NASCI=(N-IZERO)/IEX
41100 C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
41200 END
41300